home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / tpl60n19.zip / TESTPRGS.ZIP / MAINVARS.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-27  |  18KB  |  581 lines
  1. {$a+,n-,x-,s-,i-,r-,b-,v-}
  2. unit mainvars;
  3.  
  4. interface
  5. { (C) Apr 19 1983 in BASIC version by:
  6.       Professor W M Kahan,
  7.       567 Evans Hall.
  8.       Electrical Engineering & Computer Science Dept.
  9.       University of California
  10.       Berkeley, California 94720
  11.       USA
  12.  converted to Pascal by:
  13.       B A Wichmann
  14.       National Physical Laboratory
  15.       Teddington Middx
  16.       TW11 OLW
  17.       UK
  18.  further massaging by dmg =
  19.       David M. Gay
  20.       AT&T Bell Labs
  21.       600 Mountain Avenue
  22.       Murray Hill, NJ 07974
  23.  and a couple of bug fixes from dgh = sun!dhough (29 May 1986)
  24.  
  25.  See the article by Richard Karpinski in the February 1985 issue
  26.  of BYTE Magazine.
  27.  
  28.  You may copy this program freely if you acknowledge its source.
  29.  Comments on the Pascal version to NPL or dmg, please.  }
  30.  
  31.    const
  32.       {integer constants}
  33.       NoTrials = 20;
  34.       {Number of tests for commutativity. }
  35.  
  36.    type
  37.       Guard = (Yes, No);
  38.       Rounding = (Chopped, Rounded, Other);
  39.       Message = packed array [1..40] of char;
  40.       WhichOp = packed array [1..14] of char;
  41.       Class = (Flaw, Defect, SeriousDefect, Failure);
  42.  
  43.    var
  44.       {input: text;}
  45.       {Small floating point constants.}
  46.       Zero, { 0.0; }
  47.       Half, { 0.5; }
  48.       One, { 1.0; }
  49.       Two, { 2.0; }
  50.       Three, { 3.0; }
  51.       Four, { 4.0; }
  52.       Five, { 5.0; }
  53.       Eight, { 8.0; }
  54.       Nine, { 9.0; }
  55.       TwentySeven, { 27.0; }
  56.       ThirtyTwo, { 32.0; }
  57.       TwoForty, { 240.0; }
  58.       MinusOne, { -1.0; }
  59.       OneAndHalf: { 1.5; } real;
  60.       MyZero: integer;
  61.       NoTimes, Index: integer;
  62.       ch: char;
  63.       AInverse, A1: real;
  64.       Radix, BInverse, RadixD2, BMinusU2: real;
  65.       C, CInverse: real;
  66.       D, FourD: real;
  67.       E0, E1, Exp2, MinSqrtError: real;
  68.       SqrtError, MaxSqrtError, E9: real;
  69.       Third: real;
  70.       F6, F9: real;
  71.       H, HInverse: real;
  72.       I: integer;
  73.       StickyBit, J: real;
  74.       M, N, N1: real;
  75.       Precision: real;
  76.       Q, Q9: real;
  77.       R, R9: real;
  78.       T, Underflow, S: real;
  79.       OneUlp, UnderflowThreshold, U1, U2: real;
  80.       V, V0, V9: real;
  81.       W: real;
  82.       X, X1, X2, X8, RandomNumber1: real;
  83.       Y, Y1, Y2, RandomNumber2: real;
  84.       Z, PseudoZero, Z1, Z2, Z9: real;
  85.       NoErrors: array [Class] of integer;
  86.       Milestone: integer;
  87.       PageNo: integer;
  88.       GMult, GDiv, GAddSub: Guard;
  89.       RMult, RDiv, RAddSub, RSqrt: Rounding;
  90.       Continue, Break, Done, NotMonot, Monot, AnomolousArithmetic, IEEE,
  91.             SquareRootWrong, UnderflowNotGradual: Boolean;
  92.       { Computed constants. }
  93.       {U1  gap below 1.0, i.e, 1.0-U1 is next number below 1.0 }
  94.       {U2  gap above 1.0, i.e, 1.0+U2 is next number above 1.0 }
  95.  
  96.    procedure Page;
  97.    function Int (X: real): real;
  98.    function Sign (X: real): real;
  99.    procedure Pause;
  100.    procedure Instructions;
  101.    procedure Heading;
  102.    procedure Characteristics;
  103.    procedure History;
  104.    procedure notify(T: WhichOp);
  105.    procedure TestCondition (K: Class; Valid: Boolean; T: Message);
  106.    function Random: real;
  107.    procedure SqrtXMinX (ErrorKind: Class);
  108.    procedure NewD;
  109.    procedure SubRout3750;
  110.    function Power (X, Y: real): real;
  111.    procedure DoesYequalX;
  112.    procedure SubRout3980;
  113.    procedure PrintIfNPositive;
  114.    procedure TestPartialUnderflow;
  115.  
  116. implementation
  117.  
  118.    procedure Page;
  119.      begin
  120.        (* write(#$C) *) {FF in TURBO Pascal} writeln; writeln;
  121.        end;
  122.  
  123.    function Int (X: real): real;
  124.    {  simulates BASIC INT-function, which is defined as:
  125.       INT(X) is the greatest integer value less than or
  126.       equal to X. }
  127.  
  128.  
  129.       function LargeTrunc (X: real): real;
  130.  
  131.          var
  132.             start, acc, y, p: real;
  133.             trunced: integer; (* dgh *)
  134.  
  135.          begin (* LargeTrunc *)
  136.          if abs (X) < maxint then begin
  137.             trunced := trunc(X);
  138.             LargeTrunc := trunced;
  139.             end
  140.          else
  141.             begin
  142.             start := abs (X);
  143.             acc := 0.0;
  144.             repeat
  145.                y := start;
  146.                p := 1.0;
  147.                while y > maxint - 1.0 do
  148.                   begin
  149.                   y := y / Radix;
  150.                   p := p * Radix;
  151.                   end;
  152.                trunced := trunc(y);
  153.                acc := acc + trunced * p;
  154.                start := start - trunced * p;
  155.             until start < 1.0;
  156.             if X < 0.0 then
  157.                LargeTrunc := - acc
  158.             else
  159.                LargeTrunc := acc
  160.             end;
  161.          end (* LargeTrunc *);
  162.  
  163.  
  164.       begin (* Int *)
  165.       if X > 0.0 then
  166.          Int := LargeTrunc (X)
  167.       else if LargeTrunc (X - 0.5) = X then
  168.          Int := X
  169.       else
  170.          Int := LargeTrunc (X) - 1;
  171.       end (* Int *);
  172.  
  173.  
  174.    function Sign (X: real): real;
  175.  
  176.       begin (* Sign *)
  177.       if X < 0.0 then
  178.          Sign := - 1.0
  179.       else
  180.          Sign := + 1.0;
  181.       end (* Sign *);
  182.  
  183.  
  184.    procedure Pause;
  185.  
  186.       var
  187.          ch: char;
  188.  
  189.       begin (* Pause *)
  190.       writeln ('To continue, press any key and newline:');
  191.       readln (input);
  192.       while not eoln (input) do
  193.          read (input, ch);
  194.       Page;
  195.       write ('Diagnosis resumes after milestone no ', Milestone);
  196.       writeln ('               Page: ', PageNo);
  197.       writeln;
  198.       Milestone := Milestone + 1;
  199.       PageNo := PageNo + 1;
  200.       end (* Pause *);
  201.  
  202.  
  203.    procedure Instructions;
  204.  
  205.       begin (* Instructions *)
  206.       writeln ('Lest this program stop prematurely, ',
  207.             'i.e. before displaying');
  208.       writeln ('         "END OF TEST",');
  209.       writeln ('try to persuade the computer NOT to',
  210.             ' terminate execution whenever an');
  211.       writeln ('error like Over/Underflow or Division by Zero occurs,',
  212.             ' but rather');
  213.       writeln ('to persevere with a surrogate value after, ',
  214.             ' perhaps, displaying some');
  215.       writeln ('warning.  If persuasion avails naught, don''t despair'
  216.             , ' but run this');
  217.       writeln ('program anyway to see how many milestones it passes,',
  218.             ' and then');
  219.       writeln ('amend it to make further progress.');
  220.       writeln ('Answer questions with Y, y, N or n',
  221.             ' (unless otherwise indicated).');
  222.       writeln;
  223.       end (* Instructions *);
  224.  
  225.  
  226.    procedure Heading;
  227.  
  228.       begin (* Heading *)
  229.       writeln ('Users are invited to help debug and augment',
  230.             ' this program so it will');
  231.       writeln ('cope with unanticipated and newly uncovered',
  232.             ' arithmetic pathologies.');
  233.       writeln ('Please send suggestions and interesting results to');
  234.       writeln('        Richard Karpinski');
  235.       writeln('        Computer Center U-76');
  236.       writeln('        University of California');
  237.       writeln('        San Francisco, CA 94143-0704, USA');
  238.       writeln;
  239.       writeln('In doing so, please include the following information:');
  240.       writeln('        Version:  10 February 1989');
  241.       writeln('        Computer:'); writeln;
  242.       writeln('        Compiler:'); writeln;
  243.       writeln('        Optimization level:'); writeln;
  244.       writeln('        Other relevant compiler options:'); writeln;
  245.       end (* Heading *);
  246.  
  247.  
  248.    procedure Characteristics;
  249.  
  250.       begin (* Characteristics *)
  251.       writeln (
  252.             'Running this program should reveal these characteristics');
  253.       writeln ('  Radix = 1, 2, 4, 8, 10, 16, 100, 256, or ...');
  254.       writeln ('  Precision = number of significant digits carried.');
  255.       writeln ('  U2 = Radix/Radix^Precision = One Ulp (OneUlpnit in the');
  256.       writeln ('    Last Place) of 1.000xxx .');
  257.       writeln ('  U1 = 1/Radix^Precision = One Ulp of numbers',
  258.             ' a little less than 1.0 .');
  259.       writeln ('  Adequacy of guard digits for Mult., Div., and Subt.');
  260.       writeln ('  Whether arithmetic is chopped, correctly rounded, ',
  261.             'or something else');
  262.       writeln ('    for Mult., Div., Add/Subt. and Sqrt.');
  263.       writeln ('  Whether a Sticky Bit is used correctly for rounding.');
  264.       wr